(in-package #:experiment)

(define-condition navigation ()
  ())

(define-condition onward (navigation)
  ((return-value :initarg :return :accessor onward-return-value))
  (:report (lambda (c stream)
             (format stream "Onward request with return value: ~s"
                     (onward-return-value c)))))

(define-condition backward (navigation)
  ()
  (:report (lambda (c stream)
             (declare (ignore c))
             (format stream "backward request"))))

(defclass state (gwee:view)
  ())

(defgeneric state-run (experiment state))
(defgeneric state-init (experiment state))
(defgeneric state-clean-up (experiment state))
(defgeneric state-dispatch-event (experiment state event))
(defgeneric state-translate-action (state name &rest args &key &allow-other-keys)
  (:documentation "Allow states to have alternate actions that are
more user-friendly for model developers. The action is translated into
the corresponding native action and executed."))
(defgeneric state-unhandled-event (experiment state event))
(defgeneric state-onward (experiment state &optional retval))
(defgeneric state-backward (experiment state)
  (:documentation "Go to the previous state. This is usually used for
debugging or exploring."))
(defgeneric state-dump (experiment state)
  (:method-combination append :most-specific-last))
(defgeneric state-list-actions (experiment state)
  (:method-combination append :most-specific-last)
  (:documentation "List possible actions given the current state."))
(defgeneric state-list-objects (experiment state)
  (:method-combination append :most-specific-last)
  (:documentation "List possible actions given the current state."))
(defgeneric compile-state (experiment state args))

(defun default-list-actions (state)
  (remove-duplicates
   (possible-actions state)
   :test 'equal))

(defmethod state-translate-action (state name &rest keys &key &allow-other-keys)
  ;; The default is to just pass it through to execute-action
  (if (action-match-structure name state)
      (let ((state-values (action-states-values (action-match-structure name state) state)))
        ;; (print `(values ,state-values))
        (exp:execute-action name state (append keys state-values)))
      (error "~a is not an action for the state ~a" name (type-of state))))

(defmethod state-clean-up (experiment state)
  (log experiment 'end))

(defmethod state-init (experiment (state state))
  )

(defmethod state-dump append (experiment (state t))
  `(,(type-of state)))

(defmethod state-run :around (experiment (state state))
  (with-current-state (experiment state)
    (unwind-protect
         (progn
           (save-experiment experiment)
           (handler-case
               (progn
                 ;; We need to make sure the new state is visible.
                 (setf (gwee:switchable-layout-current-view experiment) state)
                 (state-init experiment state)
                 (call-next-method))
             (onward (c)
               (onward-return-value c))))
      (state-clean-up experiment state))))

(defmethod state-run (experiment (state state))
  (gwee:dispatch-events))

(defmethod state-list-actions append (experiment (state state))
  nil)

(defmethod state-list-objects append (experiment (state state))
  nil)

(defmethod state-list-actions append (experiment (state null))
  nil)

(defmethod state-list-objects append (experiment (state null))
  nil)

(defmethod state-onward (experiment (state state) &optional retval)
  (gwee:cancel-all-timers)
  (signal 'onward :return retval))

(defmethod state-dispatch-event (experiment state event)
  ;; FIXME: is this assertion needed?
  (assert (eq state (current-state experiment))
	  () "~a /= ~o" state (current-state experiment))
  ;; (print `(dispatch-event ,event))
  (unless (match-event-execute-actions state event)
    (state-unhandled-event experiment state event)))

(defmethod state-dispatch-event (experiment (state null) event)
  )

(defmethod state-unhandled-event (exp (state state) (event event))
  )

(defmethod state-backward (exp (state state))
  (gwee:cancel-all-timers)
  (signal 'backward))

(defmethod compile-state (experiment (state state) args)
  (apply 'make-instance (type-of state) :parent experiment args))

(defmethod compile-state (experiment (state symbol) args)
  (compile-state experiment (allocate-instance (find-class state)) args))
